home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / make-test.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  2KB  |  48 lines
  1. (in-package :pcl)
  2.  
  3. (defun top-level-form-form (form)
  4.   #+cmu
  5.   (if (and (consp form) (eq (car form) 'eval-when))
  6.       (third form)
  7.       form)
  8.   #+kcl
  9.   (fourth (third form))
  10.   #+lcl3.0
  11.   (third (third form)))
  12.  
  13. (defun make-test ()
  14.   (let ((table (make-hash-table :test 'eq))
  15.     (count 0))
  16.     (labels ((fixup (form)
  17.            (if (consp form)
  18.            (cons (fixup (car form)) (fixup (cdr form)))
  19.            (if (and (symbolp form) (null (symbol-package form)))
  20.                (or (gethash form table)
  21.                (setf (gethash form table)
  22.                  (intern (format nil "~A-%-~D" (symbol-name form)
  23.                          (incf count))
  24.                      *the-pcl-package*)))
  25.                form))))
  26.       (with-open-file (out "test.lisp"
  27.                :direction :output :if-exists :supersede)
  28.     (declare (type stream out))
  29.     (let ((*print-case* :downcase)
  30.           (*print-pretty* t)
  31.           (*package* *the-pcl-package*))
  32.       (format out "~S~%" '(in-package :pcl))
  33.       (let ((i 0)
  34.         (f (macroexpand '(PRECOMPILE-FUNCTION-GENERATORS PCL))))
  35.         (dolist (form (cdr (top-level-form-form f)))
  36.           (let ((name (intern (format nil "FGEN-~D" (incf i)))))
  37.         (format out "~S~%" `(defun ,name () ,(fixup form))))))
  38.       (let ((i 0)
  39.         (f (macroexpand '(PRECOMPILE-DFUN-CONSTRUCTORS PCL))))
  40.         (dolist (form (cdr f))
  41.           (let ((name (intern (format nil "DFUN-CONSTR-~D" (incf i))))
  42.             (form (top-level-form-form form)))
  43.         (format out "~S~%" `(defun ,name () 
  44.                       (list ,(second form)
  45.                             ,(third form)
  46.                             ,(fixup (macroexpand (fifth form))))))))))))))
  47.  
  48.